use 5.10.0;
package Graphics::PlanarVector::Path;
use List::Util qw/reduce min/;
use Carp;

use Graphics::PlanarVector::Vector qw/vector veq/;
use Graphics::PlanarVector::Transform
	qw/matrix_translate matrix_rotate matrix_scale/;
use Graphics::PlanarVector::PathSegment 'path_segment';
use Graphics::PlanarVector::SubPath qw/subpath bbox intersect/;
use Exporter 'import';
our @EXPORT_OK = qw/path/;

use fields qw/kids flags bbox/;

use constant {
	PATH_NOCROSS=> 1 << 0,
	PATH_WINDING=> 1 << 1,
};

sub calc_depth;
use overload (
	'""'	=> sub {
		my ($sp, $ret) = (shift, "path {\n");
		for ($sp->kids) { $ret .= "$_" }
		$ret."}\n";
	},
	'='	=> \&dup,
	'&'	=> \&path_and,
	'|'	=> \&path_or,
	'^'	=> \&path_xor,
	'-'	=> \&path_minus,
	'+'	=> \&path_combine,
);

sub path {
	my $self = fields::new(__PACKAGE__);
	$self->{kids} = @_? [@_] : [subpath()];
	$self->{flags} = 0;
	$self
}

sub dup {
	my $self = shift;
	my $new = path(map { $_->dup } @{$self->{kids}});
	$new->{bbox} = $self->{bbox};
	$new->{flags} = $self->{flags};
	$new
}

sub kids { grep { @{$_->{kids}} } @{shift->{kids}} }

sub transform {
	my ($sp, $m) = @_;
	path(map { $_->transform($m) } $sp->kids);
}

sub rotate {
	my $p = shift;
	$p->transform(&matrix_rotate)->set_flags($p->{flags});
}

sub translate {
	my $p = shift;
	$p->transform(&matrix_translate)->set_flags($p->{flags});
}

sub scale {
	my $p = shift;
	my $m = &matrix_scale;
	my $new = $p->transform($m);

	if ($p->{flags}) {
		if ($m->[0] * $m->[3] > 0) {
			$new->set_flags($p->{flags})
		} else {
			$new = $new->reverse->set_flags($p->{flags})
		}
	}
	$new
}

sub _cur_sub {
	shift->{kids}->[-1]
}

sub _vecs {
	my @ret;
	while (@_) {
		my $a = shift;
		ref $a and push(@ret, $a), next;
		my $b = shift;
		defined($b) && !ref($b)	or  croak "bad vector list";
		push @ret, vector $a, $b;
	}
	wantarray ? @ret : $ret[-1]
}

sub current_point {
	&_cur_sub->current_point
}

sub moveto {
	my $path = shift;
	my $pt = &_vecs;
	my $last = _cur_sub($path);
	if (!@{$last->{kids}}) {
		$last->{start} = $pt;
	} else {
		push @{$path->{kids}}, subpath($pt);
	}
	$path
}

sub rmoveto {
	my $path = shift;
	my $pt = $path->current_point + &_vecs;
	moveto($path, $pt);
}

sub closepath {
	my $path = shift;
	my $sp = _cur_sub($path);
	return unless $sp->{kids};

	push @{$path->{kids}}, subpath($sp->close_sub);
	$path
}

# curve order depends on args length
sub curveto {
	my $path = shift;
	my $cur = current_point($path);
	my $sp = _cur_sub($path);
	$sp->add_segment($cur, &_vecs);
	$path;
}

sub rcurveto {
	my $path = shift;
	my $cur = current_point($path);
	my $sp = _cur_sub($path);
	my @v = map { $cur + $_ } &_vecs;
	$sp->add_segment($cur, @v);
	$path;
}

sub smoothto {
	my $path = shift;
	my $cur = current_point($path);
	my $sp = _cur_sub($path);
	my @v = &_vecs;

	my $c;
	if (!@{$sp->{kids}} || @{$sp->{kids}[-1]} != 4 + @v) {
		$c = $v[0]
	} else {
		$c = $v[0] * 2 - $sp->{kids}[-1][-2]
	}
	$sp->add_segment($cur, $c, @v);
	$path;
}

sub rsmoothto {
	my $path = shift;
	my $cur = current_point($path);
	my $sp = _cur_sub($path);
	my @v = map { $cur + $_ } &_vecs;

	my $c;
	if (!@{$sp->{kids}} || @{$sp->{kids}[-1]} != 4 + @v) {
		$c = $v[0]
	} else {
		$c = $v[0] * 2 - $sp->{kids}[-1][-2]
	}
	$sp->add_segment($cur, $c, @v);
	$path;
}

sub reverse {
	my $p = shift;
	my $new = path;
	$new->{kids} = [ map { $_->reverse } $p->kids ];
	$new->set_flags($p->{flags} & PATH_NOCROSS);
	$new;
}

sub approx {
	join ',', map { 0 + sprintf("%.3f", $_) } @{shift()}
}

sub fix_winding {
	my $eo = shift;
	my @out;
	if ($eo) {
		for (@_) {
			push @out, ($_->{depth} & 1) ? $_->reverse : $_
		}
	} else {
		for my $s (@_) {
			given($s->{depth}) {
			when (-1) {
				push @out, $s->reverse
			}
			when (0) {
				push @out, $s
			}}
		}
	}
	@out
}

sub cleanup {
	for (shift->kids) { $_->cleanup }
}

sub edges {
	grep { $_->order > 1 || !veq(@{$_->{pt}}) }
	map { $_->kids }
	map { $_->kids }
	@_
}

sub write_segs {
	my @out;
	for (@_) {
		my @pt = @{$_->{pt}};
		push @out, "M $pt[0]";
		if (@pt == 2) {
			$out[-1].="	L $pt[1]"
		} elsif (@pt == 3) {
			$out[-1].="	Q $pt[1] $pt[2]"
		} else {
			$out[-1].="	C $pt[1] $pt[2] $pt[3]"
		}
	}
	return @out
}

sub seg_merge {
	if ($_[0]->order == 1 && $_[-1]->order == 1) {
		my ($i, $d1, $d2) = (0, $_[0]->poly_form->[1]);
		while ($i < @_-1) {
			if ($_[$i+1]->order > 1 or
				abs(($d2 = $_[$i+1]->poly_form->[1]) ^ $d1) > 1e-8)
			{
				my @r = splice(@_, 0, $i+1);
				push @_, @r;
				last;
			}
			$d1 = $d2;
			++$i;
		}
	}

	my @r;
OUTER:
	while (my $this = shift) {
		if ($this->order > 1) {
			push @r, $this;
			next
		}
		my $d1 = $this->poly_form->[1];
		my ($end, $that);
		while($that = shift) {
			if ($that->order > 1) {
				push @r, $this, $that;
				next OUTER;
			}
			if (abs($that->poly_form->[1] ^ $d1) > 1e-8) {
				last;
			} else {
				$this = path_segment($this->{pt}[0], $that->{pt}[1]);
			}
		}
		push @r, $this;
		last unless $that;
		$this = $that;
		redo;
	}
	if (@r == 1) { @r = () }
	\@r
}

sub cmp_edges {
	$a->{angle} <=> $b->{angle} or do {
		$a->{poly} //= $a->{out}
				? $a->{seg}->poly_form->down
				: $a->{seg}->reverse->poly_form->down;
		$b->{poly} //= $b->{out}
				? $b->{seg}->poly_form->down
				: $b->{seg}->reverse->poly_form->down;
		my $x = $a->{poly} ^ $b->{poly};
		for (@$x) {
			next if abs($_) < 1e-8;
			return -$_
		}
	};
}

sub self_intersect {
	Graphics::PlanarVector::SubPath::intersect
		map { $_->self_intersect } shift->kids;
}

sub remove_double {
	my $eo = shift;
	my @segs = @_;
	map {delete $_->{rem} }@_;
	while (my $this = shift) {
		next if defined $this->{rem};
		if (@{$this->{pt}} < 2 or 
			@{$this->{pt}} == 1 && veq(@{$this->{pt}})) {
			$this->{rem} = 1;
			next;
		};

		my $rev = $this->reverse;
		for (@_) {
			next if defined $_->{rem};
			if ($rev->seg_equal($_) or
				$eo && $this->seg_equal($_)
			) {
				$this->{rem} = $_->{rem} = 1;
				last;
			}
		}
	}
	grep { !defined $_->{rem} } @segs;
}

sub join_segs {
	my (%nodes, %segs, $i, $j);
	for (	map { {seg=>$_} }
		grep { $_->order != 1 or !($_->{pt}[0]->veq($_->{pt}[1])) }
		@_
	){
		my $s = $_->{seg};
		$segs{$s->{uid}} = $_;

		my $n = approx($s->{pt}[0]);
		push @{$nodes{$n}}, {seg=>$s, out=>1, angle=>$s->tangent(0)->angle};
		$n = approx($s->{pt}[-1]);
		push @{$nodes{$n}}, {seg=>$s, out=>-1, angle=>$s->reverse->tangent(0)->angle};
	}

	while (my ($k, $v) = each %nodes) {
		my @list = sort cmp_edges @$v;
		if (reduce { $a + $b } map { $_->{out} } @list) {
			local $\ = "\n";
			local $, = "";
			print STDERR "\nedges:\t", join("\n\t", map { "$_->{seg}"} values %segs);
			print STDERR "\nnodes: ", join(", ", keys %nodes);
			print STDERR "\nSVG:\t".join("\n\t",write_segs(@_));
			croak "bad node: $k\n\n\t" . join("\n\t", map {$_->{seg}} @list);
		}
		for ($i = $#list; $i > 0; $i--) {
			next if $i >= @list;
			if ($list[$i]{out} != $list[$i-1]{out}) {
				my ($this, $that) = map { $list[$_]{seg}{uid} }
					($list[$i]{out} == 1 ? ($i-1, $i) : ($i, $i-1));
				$segs{$this}{next} = $that;

				splice @list, $i-1, 2;
				$i++;
			}
		}
	}

	my (@segs, @loops) = values %segs;
	for ($i = 0; $i < @segs; $i++) {
		next if $segs[$i]{used};
		my @loop;
		$j = $segs[$i]{seg}{uid};

		while (!$segs{$j}{used}) {
			my $s = $segs{$j};
			$s->{used} = 1;
			push @loop, $s->{seg};
			$j = $s->{next};
		}
		push @loops, seg_merge(@loop);
	}
	path(map {
		my $sub = subpath();
		$sub->{kids} = $_;
		$sub->{closed} = 1;
		$sub
	} @loops)->set_flags(PATH_WINDING | PATH_NOCROSS)
}

sub set_flags {
	my ($p, $f) = @_;
	if ($f) {
		$p->{flags} = $f;
		for ($p->kids) { $_->{flags} = $f }
	}
	$p
}

sub write_dbg_svg {
	my @segs = @_;
	local $\ = "";
	local $, = "";
	my %colors = (-1=>'blue', 0=>'black', 1=>'red');
	open OUT, '>/tmp/dbg.svg';
	print OUT '<svg xmlns="http://www.w3.org/2000/svg">
';
	for (@segs) {
		my @pt = @{$_->{pt}};
		my $p = path;
		$p->moveto(shift @pt);
		$p->curveto(@pt);
		print OUT '<path d="'.$p->SVG_out.'" fill="none" stroke="',
			$colors{$_->{depth}}//'green', '"/>
';
	}
	print OUT '</svg>';
	close OUT;

}

sub calc_depth {
	my $ext = reduce { $a | $b } map { delete $_->{depth}; delete $_->{sect}; $_->bbox } @_;
	return unless defined $ext;

	my $d = ($ext->[1] - $ext->[0]) / 4;
	$ext->[0] -= $d; $ext->[1] += $d;
	$d = ($ext->[3] - $ext->[2]) / 4;
	$ext->[2] -= $d; $ext->[3] += $d;

	for my $seg (@_) {
		next if exists $seg->{depth};
		my $bbox = $seg->bbox;
		my ($ray, $dir);

		if ($bbox->[1] - $bbox->[0] < $bbox->[3] - $bbox->[2]) {
			my $y = $bbox->[2] + ($bbox->[3] - $bbox->[2]) * (rand(.4) + .3);
			$ray = path_segment($ext->[0], $y, $ext->[1], $y);
			$dir = vector(1, 0);
		} else {
			my $x = $bbox->[0] + ($bbox->[1] - $bbox->[0]) * (rand(.4) + .3);
			$ray = path_segment($x, $ext->[2], $x, $ext->[3]);
			$dir = vector(0, 1);
		}

		for (@_) { $ray->intersect($_, 1) };

		my $depth = 0;
		for (sort { $a->[0] <=> $b->[0] } @{$ray->{sect}}) {
			my $t = ($dir^$_->[2]->tangent($_->[1])) <=> 0;
			$_->[2]{depth} //= ($t > 0 ? $depth : ($depth - 1));
			$depth += $t;
		}
	}

	@_
}

sub unwind {
	my $p = shift->dup;
	if ($p->{flags} & PATH_NOCROSS) {
		return (($p->{flags} & PATH_WINDING)
			? $p
			: $p->reverse->set_flags(PATH_WINDING|PATH_NOCROSS)
		)
	}

	for ($p->kids) { $_->close_sub }

	my $eo = shift // 0;
	$p->self_intersect;

	my @segs =
		calc_depth
		remove_double $eo,
		map { $_->split }
		$p->edges;

	my $ret;
	eval {
		$ret = $eo
		? join_segs fix_winding 1, @segs
		: join_segs fix_winding 0,
			grep { $_->{depth} == -1 || $_->{depth} == 0 }
			@segs
	};
	if ($@) {
		print STDERR "Failed to unwind path\n".$p->SVG_out
			."\nSegments are:\n\t"
			.join("\n\t", map { $_->{depth}.": "
			.join('', write_segs($_)) } @segs)
			."\n\t========== Error was:\n";
		confess $@
	}
	return $ret
}

sub path_combine {
	pop @_ unless ref $_[-1];
	path(	map { $_->close_sub; $_ }
		map { $_->dup->kids}
		@_
	)
}

sub path_minus {
	my @ps = (shift->unwind, shift->unwind->reverse);
	intersect @ps;
	join_segs
		fix_winding 1,
		grep { $_->{depth} >= 0 }
		calc_depth
		remove_double 0,
		map { $_->split }
		edges
		@ps;
}

sub path_xor {
	my @ps = (shift->unwind, shift->unwind->reverse);
	intersect @ps;
	join_segs
		fix_winding 1,
		calc_depth
		remove_double 0,
		map { $_->split }
		edges
		@ps;
}

sub path_or {
	pop unless ref $_[-1];
	my @ps = map { $_->unwind } @_;
	intersect @ps;
	join_segs
		fix_winding 0,
		grep { $_->{depth} == -1 || $_->{depth} == 0 }
		calc_depth
		remove_double 0,
		map { $_->split }
		edges
		@ps;
}

sub path_and {
	pop unless ref $_[-1];
	my @ps = map { $_->unwind } @_;
	intersect @ps;
	join_segs
		fix_winding 1,
		grep { $_->{depth} == 1 }
		calc_depth
		remove_double 0,
		map { $_->split }
		edges
		@ps;
}

sub point { shift->bbox->interp(@_) }

1;

__END__

=head1 NAME

B<Graphics::PlanarVector::Path> -- Vector graphics path object consisting of
lines, quadratic and cubic Bezier curves.

=head1 SYNOPSIS

    use Graphics::PlanarVector::Path 'path';
    $path = path();
    $path->moveto(0, 0)->curveto(50,0, 100,100)->closepath;
    $path2 = $path->rotate(30)->reverse;
    $path3 = $path | $path2;

=head1 Functions

=over 4

=item B<path>()

Importable function.  Returns a path object. Cannot be called as a method.

=item $path->B<moveto>(POINT)

Object method. C<< $path->moveto(POINT) >> moves the current position of
C<$path> to C<POINT>, where C<POINT> can be either a pair of numbers C<(x, y)>

	$path->moveto($x, $y),

or a L<Graphics::PlanarVector::Vector> object

	$path->moveto($vector).

=item $path->B<rmoveto>(POINT)

Object method.  Move to position indicated by C<POINT>, relative to currerent
position.

=item $path->B<curveto>(POINT[, POINT, POINT])

Object method.  Appends a segment, starting at current position.  Depending
on the number of C<POINT> arguments, it adds either a line (1), a quadratic
Bezier (2), or a cubic Bezier (3).  In any case, the final C<POINT> is the
new position of the curve, while the C<POINT>s before it are control points.

=item $path->B<rcurveto>(POINT, [POINT, POINT])

Object method.  Same as B<curveto>, except the positions are relative.

=item $path->B<smoothto>(POINT, [POINT])

Object method.  Similar to B<curveto>, but with first control point reflected
from last segment in path (think 'T' and 'S' command in SVG path data).

=item $path->B<rsmoothto>(POINT, [POINT])

Object method.  Same as B<smoothto>, but coordinates are relative.

=item $path->B<closepath>

Object method.  Closes the current subpath.  Subsequent move and draw commands
will operate on a new subpath.

=item $path->B<dup>

Object method.  Produces a deep clone of C<$path>.

=item $path->B<scale>($scale_x[, $scale_y, $origin])

Object method.  Produces a new object that's a scaled version of C<$path>.
If both C<$scale_y> and C<$origin> are omitted, $scale_y is the same as
C<$scale_x> while C<$origin> is set to C<(0, 0)>.  If C<$origin> is provided,
it must be a L<Graphics::PlanarVector::Vector> object, and C<$scale_y> cannot
be omitted.

=item $path->B<rotate>($angle[, POINT])

Object method.  Produces a new object equivalent to C<$path> rotated by
C<$angle> degrees around C<POINT>.  If C<POINT> is omitted, it's taken to be
C<(0, 0)>.

=item $path->B<translate>($x, $y)

Object method.  Produces a new object equivalent to C<$path> moved by
C<($x, $y)>.

=item $path->B<transform>($matrix)

Object method.  Does a general transformation according to C<$matrix>, which
must be a L<Graphics::PlanarVector::Transform> object.

=item $path->B<unwind>($evenodd)

Object method.  Produces a new path object that has same filled coverage as
the original $path with the filling rule (even-odd fill if $evenodd is true;
non-zero fill otherwise).  The new path is "unwound" in the sense that it
has no intersecting edges and has the same fill effect regardless of the
winding rule applied.

=item $path1->B<path_or>($path2[, $path3, ...])  and operator 'B<|>'

Object method.  Produces a unwound new path covering the fill area that's the
union of the fill areas coverd by all of $path1, $path2, etc.  as if they were
all using non-zero winding rule.  If any of them should be even-odd filled,
use C<< $path->unwind(1) >> first.

Operator '|' is overloaded.  C<$path1 | $path2> is the same as C<< $path1->path_or($path2) >>.

=item $path1->B<path_and>($path2[, $path3, ...]) and operator 'B<&>'

Similar to C<path_or>, but new path covers the fill area common in all the
paths.  C<< $path1 & $path2 >> is the same as C<< $path1->path_and($path2) >>.

=item $path1->B<path_xor>($path2) and operator 'B<^>'

Similar to C<path_or>, but new path covers the fill area that's in either
C<$path1> or C<$path2>, but not in both. C<< $path1 ^ $path2 >> is the same
as C<< $path1->path_xor($path2) >>.

=item $path1->B<path_minus>($path2) and operator 'B<->'

Similar to C<path_or>, but new path covers the fill area that's in
C<$path1> and I<not> C<$path2>. C<< $path1 - $path2 >> is the same
as C<< $path1->path_minus($path2) >>.

=item $path1->B<path_combine>($path2[, $path3, ...]) and operator 'B<+>'

Produces a new path that contains all the edges in the original paths.  No
unwinding is done.  C<< $path1 + $path2 >> is the same as
C<< $path1->path_combine($path2) >>.

=item Printing

Operator 'B<"">' is also overloaded.  C<< print $path >> produces a nested
text output of the C<$path> object that may be useful for debugging.

=back

=head1 BUGS AND MALFEATURES

The Bezier arithmetics are done with polynomial solving and requires the
L<Math::Polynomial::Solve> package from CPAN.  Calculating cubic-cubic Bezier
intersections generally means finding roots for a 9-th order polynomial, so
sometimes the root-finding can be very slow and inaccurate; occasionally the
path unwinding function will fail altogether.  There is no good solution
for now, fortunately it doesn't happen all that often.

To account for the imprecission of calculations, the program pretends all nodes
on a path within roughly 0.001 distance of each other are the same.  This is not
mathematically correct, but for most applications the output will not be
visually different from the correct answer.

This module does not directly interface with different vector file formats.
See L<Graphics::SVG::Path> for an example SVG path data input/output.

=cut
